home *** CD-ROM | disk | FTP | other *** search
- ;;; CMPENV Environments of the Compiler.
- ;;;
- ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
- ;; Copying of this file is authorized to users who have executed the true and
- ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
-
- (in-package 'compiler)
-
- (defvar *safe-compile* nil)
- (defvar *compiler-check-args* nil)
- (defvar *compiler-push-events* nil)
- (defvar *speed* 3)
- (defvar *space* 0)
-
- ;;; Only these flags are set by the user.
- ;;; If *safe-compile* is ON, some kind of run-time checks are not
- ;;; included in the compiled code. The default value is OFF.
-
- (defun init-env ()
- (setq *next-cvar* 0)
- (setq *next-cmacro* 0)
- (setq *next-vv* -1)
- (setq *next-cfun* 0)
- (setq *last-label* 0)
- (setq *objects* nil)
- (setq *constants* nil)
- (setq *local-funs* nil)
- (setq *global-funs* nil)
- (setq *global-entries* nil)
- (setq *undefined-vars* nil)
- (setq *reservations* nil)
- (setq *closures* nil)
- (setq *top-level-forms* nil)
- (setq *compile-time-too* *eval-when-compile*)
- (setq *non-package-operation* nil)
- (setq *function-declarations* nil)
- (setq *inline-functions* nil)
- (setq *inline-blocks* 0)
- (setq *notinline* nil)
- )
-
- (defvar *next-cvar* 0)
- (defvar *next-cmacro* 0)
- (defvar *next-vv* -1)
- (defvar *next-cfun* 0)
-
- ;;; *next-cvar* holds the last cvar number used.
- ;;; *next-cmacro* holds the last cmacro number used.
- ;;; *next-vv* holds the last VV index used.
- ;;; *next-cfun* holds the last cfun used.
-
- (defmacro next-cfun () '(incf *next-cfun*))
-
- (defun add-symbol (symbol)
- (let ((x (assoc symbol *objects*)))
- (cond (x (cadr x))
- (t (incf *next-vv*)
- (push (list symbol *next-vv*) *objects*)
- (wt-data symbol)
- *next-vv*))))
-
- (defun add-object (object &aux x)
- ;;; Used only during Pass 1.
- (cond ((si:contains-sharp-comma object)
- ;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT
- ;;; contains a sharp comma OR a structure.
- (incf *next-vv*)
- (push *next-vv* *sharp-commas*)
- (wt-data (prin1-to-string object))
- *next-vv*)
- ((setq x (assoc object *objects*))
- (cadr x))
- (t (incf *next-vv*)
- (push (list object *next-vv*) *objects*)
- (wt-data object)
- *next-vv*)))
-
- (defun add-constant (symbol &aux x)
- ;;; Used only during Pass 1.
- (cond ((setq x (assoc symbol *constants*))
- (cadr x))
- (t (incf *next-vv*)
- (push *next-vv* *sharp-commas*)
- (wt-data (prin1-to-string (cons 'si:|#,| symbol)))
- (push (list symbol *next-vv*) *constants*)
- *next-vv*)))
-
- (defmacro next-cvar () '(incf *next-cvar*))
- (defmacro next-cmacro () '(incf *next-cmacro*))
-
- ;;; Tail recursion information.
- (defvar *do-tail-recursion* t)
- (defvar *tail-recursion-info* nil)
- ;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL.
- ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
- ;;; If possible, *tail-recursion-info* holds
- ;;; ( fname required-arg .... required-arg ),
- ;;; where each required-arg is a var-object.
-
-
- (defvar *function-declarations* nil)
- ;;; *function-declarations* holds :
- ;;; (... ( { function-name | fun-object } arg-types return-type ) ...)
- ;;; Function declarations for global functions are ASSOCed by function names,
- ;;; whereas those for local functions are ASSOCed by function objects.
- ;;;
- ;;; The valid argment type declaration is:
- ;;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
- ;;; though &optional, &rest, and &key return types are simply ignored.
-
- (defun function-arg-types (arg-types &aux (types nil))
- (do ((al arg-types (cdr al)))
- ((or (endp al)
- (member (car al) '(&optional &rest &key)))
- (reverse types))
- (declare (object al))
- (push (type-filter (car al)) types)))
-
- ;;; The valid return type declaration is:
- ;;; (( VALUES {type}* )) or ( {type}* ).
-
- (defun function-return-type (return-types)
- (cond ((endp return-types) t)
- ((and (consp (car return-types))
- (eq (caar return-types) 'values))
- (cond ((not (endp (cdr return-types)))
- (warn "The function return types ~s is illegal." return-types)
- t)
- ((or (endp (cdar return-types))
- (member (cadar return-types) '(&optional &rest &key)))
- t)
- (t (type-filter (cadar return-types)))))
- (t (type-filter (car return-types)))))
-
- (defun add-function-proclamation (fname arg-types return-types)
- (cond ((symbolp fname)
- (si:putprop fname (function-arg-types arg-types)
- 'proclaimed-arg-types)
- (si:putprop fname (function-return-type return-types)
- 'proclaimed-return-type)
- ;;; A non-local function may have local entry only if it returns
- ;;; a single value.
- (if (and (not (endp return-types))
- (endp (cdr return-types))
- (not (and (consp (car return-types))
- (eq (caar return-types) 'values)
- (or (endp (cdar return-types))
- (not (endp (cddar return-types)))))))
- (si:putprop fname t 'proclaimed-function)
- (remprop fname 'proclaimed-function)))
- (t (warn "The function name ~s is not a symbol." fname))))
-
- (defun add-function-declaration (fname arg-types return-types)
- (cond ((symbolp fname)
- (push (list (sch-local-fun fname)
- (function-arg-types arg-types)
- (function-return-type return-types))
- *function-declarations*))
- (t (warn "The function name ~s is not a symbol." fname))))
-
- (defun get-arg-types (fname &aux x)
- (if (setq x (assoc fname *function-declarations*))
- (cadr x)
- (get fname 'proclaimed-arg-types)))
-
- (defun get-return-type (fname)
- (let* ((x (assoc fname *function-declarations*))
- (type1 (if x (caddr x) (get fname 'proclaimed-return-type))))
- (cond (type1
- (let ((type (get fname 'return-type)))
- (cond (type
- (cond ((setq type (type-and type type1)) type)
- (t
- (cmpwarn
- "The return type of ~s was badly declared."
- fname))))
- (t type1))))
- (t (get fname 'return-type)))
- ))
-
- (defun get-local-arg-types (fun &aux x)
- (if (setq x (assoc fun *function-declarations*))
- (cadr x)
- nil))
-
- (defun get-local-return-type (fun &aux x)
- (if (setq x (assoc fun *function-declarations*))
- (caddr x)
- nil))
-
- (defvar *sup-used* nil)
- (defvar *base-used* nil)
-
- (defun reset-top ()
- (wt "vs_top=sup;")
- (setq *sup-used* t))
-
- (defmacro base-used () '(setq *base-used* t))
-
- ;;; Proclamation and declaration handling.
-
- (defvar *alien-declarations* nil)
- (defvar *notinline* nil)
-
- (defun inline-possible (fname)
- (not (or *compiler-push-events*
- (member fname *notinline*)
- (get fname 'cmp-notinline))))
-
- (defun proclaim (decl)
- (case (car decl)
- (special
- (dolist** (var (cdr decl))
- (if (symbolp var)
- (si:*make-special var)
- (warn "The variable name ~s is not a symbol." var))))
- (optimize
- (dolist (x (cdr decl))
- (when (symbolp x) (setq x (list x 3)))
- (if (or (not (consp x))
- (not (consp (cdr x)))
- (not (numberp (cadr x)))
- (not (<= 0 (cadr x) 3)))
- (warn "The OPTIMIZE proclamation ~s is illegal." x)
- (case (car x)
- (safety (setq *compiler-check-args* (>= (cadr x) 1))
- (setq *safe-compile* (>= (cadr x) 2))
- (setq *compiler-push-events* (>= (cadr x) 3)))
- (space (setq *space* (cadr x)))
- (speed (setq *speed* (cadr x)))
- (compilation-speed (setq *speed* (- 3 (cadr x))))
- (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
- (type
- (if (consp (cdr decl))
- (proclaim-var (cadr decl) (cddr decl))
- (warn "The type declaration ~s is illegal." decl)))
- ((fixnum character short-float long-float)
- (proclaim-var (car decl) (cdr decl)))
- (ftype
- (if (or (endp (cdr decl))
- (not (consp (cadr decl)))
- (not (eq (caadr decl) 'function))
- (endp (cdadr decl)))
- (warn "The function declaration ~s is illegal." decl)
- (dolist** (fname (cddr decl))
- (add-function-proclamation fname (cadadr decl) (cddadr decl)))))
- (function
- (if (or (endp (cdr decl)) (endp (cddr decl)))
- (warn "The function declaration ~s is illegal." decl)
- (add-function-proclamation (cadr decl) (caddr decl) (cdddr decl))))
- (inline
- (dolist** (fun (cdr decl))
- (if (symbolp fun)
- (remprop fun 'cmp-notinline)
- (warn "The function name ~s is not a symbol." fun))))
- (notinline
- (dolist** (fun (cdr decl))
- (if (symbolp fun)
- (si:putprop fun t 'cmp-notinline)
- (warn "The function name ~s is not a symbol." fun))))
- ((object ignore)
- (dolist** (var (cdr decl))
- (unless (symbolp var)
- (warn "The variable name ~s is not a symbol." var))))
- (declaration
- (dolist** (x (cdr decl))
- (if (symbolp x)
- (unless (member x *alien-declarations*)
- (push x *alien-declarations*))
- (warn "The declaration specifier ~s is not a symbol." x))))
- ((array atom bignum bit bit-vector character common compiled-function
- complex cons double-float fixnum float hash-table integer keyword list
- long-float nil null number package pathname random-state ratio rational
- readtable sequence short-float simple-array simple-bit-vector
- simple-string simple-vector single-float standard-char stream string
- string-char symbol t vector signed-byte unsigned-byte)
- (proclaim-var (car decl) (cdr decl)))
- (otherwise
- (unless (member (car decl) *alien-declarations*)
- (warn "The declaration specifier ~s is unknown." (car decl))))
- )
- nil
- )
-
- (defun proclaim-var (type vl)
- (setq type (type-filter type))
- (dolist** (var vl)
- (cond ((symbolp var)
- (let ((type1 (get var 'cmp-type))
- (v (sch-global var)))
- (setq type1 (if type1 (type-and type1 type) type))
- (when v (setq type1 (type-and type1 (var-type v))))
- (when (null type1) (warn
- "Inconsistent type declaration was found for the variable ~s."
- var))
- (si:putprop var type1 'cmp-type)
- (when v (setf (var-type v) type1))))
- (t
- (warn "The variable name ~s is not a symbol." var)))))
-
- (defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)
- doc form)
- (loop
- (when (endp body) (return))
- (setq form (cmp-macroexpand (car body)))
- (cond
- ((stringp form)
- (when (or (null doc-p) (endp (cdr body)) doc) (return))
- (setq doc form))
- ((and (consp form) (eq (car form) 'declare))
- (dolist** (decl (cdr form))
- (cmpck (or (not (consp decl)) (not (symbolp (car decl))))
- "The declaration ~s is illegal." decl)
- (case (car decl)
- (special
- (dolist** (var (cdr decl))
- (cmpck (not (symbolp var))
- "The special declaration ~s contains a non-symbol ~s."
- decl var)
- (push var ss)))
- (ignore
- (dolist** (var (cdr decl))
- (cmpck (not (symbolp var))
- "The ignore declaration ~s contains a non-symbol ~s."
- decl var)
- (push var is)))
- (type
- (cmpck (endp (cdr decl))
- "The type declaration ~s is illegal." decl)
- (let ((type (type-filter (cadr decl))))
- (when type
- (dolist** (var (cddr decl))
- (cmpck (not (symbolp var))
- "The type declaration ~s contains a non-symbol ~s."
- decl var)
- (push (cons var type) ts)))))
- (object
- (dolist** (var (cdr decl))
- (cmpck (not (symbolp var))
- "The object declaration ~s contains a non-symbol ~s."
- decl var)
- (push (cons var 'object) ts)))
- ((fixnum character double-float short-float array atom bignum bit
- bit-vector common compiled-function complex cons float hash-table
- integer keyword list long-float nil null number package pathname
- random-state ratio rational readtable sequence simple-array
- simple-bit-vector simple-string simple-vector single-float
- standard-char stream string string-char symbol t vector
- signed-byte unsigned-byte)
- (let ((type (type-filter (car decl))))
- (when type
- (dolist** (var (cdr decl))
- (cmpck (not (symbolp var))
- "The type declaration ~s contains a non-symbol ~s."
- decl var)
- (push (cons var type) ts)))))
- (otherwise (push decl others))
- )))
- (t (return)))
- (pop body)
- )
- (values body ss ts is others doc)
- )
-
- (defun c1decl-body (decls body &aux (dl nil))
- (if (null decls)
- (c1progn body)
- (let ((*function-declarations* *function-declarations*)
- (*alien-declarations* *alien-declarations*)
- (*notinline* *notinline*)
- (*space* *space*))
- (dolist** (decl decls dl)
- (case (car decl)
- (optimize
- (dolist (x (cdr decl))
- (when (symbolp x) (setq x (list x 3)))
- (if (or (not (consp x))
- (not (consp (cdr x)))
- (not (numberp (cadr x)))
- (not (<= 0 (cadr x) 3)))
- (warn "The OPTIMIZE proclamation ~s is illegal." x)
- (case (car x)
- (safety (push (list 'safety (cadr x)) dl))
- (space (setq *space* (cadr x))
- (push (list 'space (cadr x)) dl))
- ((speed compilation-speed))
- (t (warn "The OPTIMIZE quality ~s is unknown."
- (car x)))))))
- (ftype
- (if (or (endp (cdr decl))
- (not (consp (cadr decl)))
- (not (eq (caadr decl) 'function))
- (endp (cdadr decl)))
- (warn "The function declaration ~s is illegal." decl)
- (dolist** (fname (cddr decl))
- (add-function-declaration
- fname (cadadr decl) (cddadr decl)))))
- (function
- (if (or (endp (cdr decl))
- (endp (cddr decl))
- (not (symbolp (cadr decl))))
- (warn "The function declaration ~s is illegal." decl)
- (add-function-declaration
- (cadr decl) (caddr decl) (cdddr decl))))
- (inline
- (dolist** (fun (cdr decl))
- (if (symbolp fun)
- (progn (push (list 'inline fun) dl)
- (setq *notinline* (remove fun *notinline*)))
- (warn "The function name ~s is not a symbol." fun))))
- (notinline
- (dolist** (fun (cdr decl))
- (if (symbolp fun)
- (progn (push (list 'notinline fun) dl)
- (push fun *notinline*))
- (warn "The function name ~s is not a symbol." fun))))
- (declaration
- (dolist** (x (cdr decl))
- (if (symbolp x)
- (unless (member x *alien-declarations*)
- (push x *alien-declarations*))
- (warn "The declaration specifier ~s is not a symbol."
- x))))
- (otherwise
- (unless (member (car decl) *alien-declarations*)
- (warn "The declaration specifier ~s is unknown."
- (car decl))))
- ))
- (setq body (c1progn body))
- (list 'decl-body (cadr body) dl body)
- )
- )
- )
-
- (si:putprop 'decl-body 'c2decl-body 'c2)
-
- (defun c2decl-body (decls body)
- (let ((*compiler-check-args* *compiler-check-args*)
- (*safe-compile* *safe-compile*)
- (*compiler-push-events* *compiler-push-events*)
- (*notinline* *notinline*)
- (*space* *space*))
- (dolist** (decl decls)
- (case (car decl)
- (safety
- (let ((level (cadr decl)))
- (declare (fixnum level))
- (setq *compiler-check-args* (>= level 1)
- *safe-compile* (>= level 2)
- *compiler-push-events* (>= level 3))))
- (space (setq *space* (cadr decl)))
- (notinline (push (cadr decl) *notinline*))
- (inline
- (setq *notinline* (remove (cadr decl) *notinline*)))
- (otherwise (baboon))))
- (c2expr body))
- )
-
- (defun check-vdecl (vnames ts is)
- (dolist** (x ts)
- (unless (member (car x) vnames)
- (cmpwarn "Type declaration was found for not bound variable ~s."
- (car x))))
- (dolist** (x is)
- (unless (member x vnames)
- (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
- )
-
- (defun proclamation (decl)
- (case (car decl)
- (special
- (dolist** (var (cdr decl) t)
- (if (symbolp var)
- (unless (si:specialp var) (return nil))
- (warn "The variable name ~s is not a symbol." var))))
- (optimize
- (dolist (x (cdr decl) t)
- (when (symbolp x) (setq x (list x 3)))
- (if (or (not (consp x))
- (not (consp (cdr x)))
- (not (numberp (cadr x)))
- (not (<= 0 (cadr x) 3)))
- (warn "The OPTIMIZE proclamation ~s is illegal." x)
- (case (car x)
- (safety
- (unless (= (cadr x)
- (cond ((null *compiler-check-args*) 0)
- ((null *safe-compile*) 1)
- ((null *compiler-push-events*) 2)
- (t 3)))
- (return nil)))
- (space (unless (= (cadr x) *space*) (return nil)))
- (speed (unless (= (cadr x) *speed*) (return nil)))
- (compilation-speed
- (unless (= (- 3 (cadr x)) *speed*) (return nil)))
- (t (warn "The OPTIMIZE quality ~s is unknown."
- (car x)))))))
- (type
- (if (consp (cdr decl))
- (let ((type (type-filter (cadr decl)))
- x)
- (dolist** (var (cddr decl) t)
- (if (symbolp var)
- (unless (and (setq x (get var 'cmp-type))
- (equal x type))
- (return nil))
- (warn "The variable name ~s is not a symbol." var))))
- (warn "The type declaration ~s is illegal." decl)))
- ((fixnum character short-float long-float)
- (let ((type (type-filter (car decl)))
- x)
- (dolist** (var (cdr decl) t)
- (if (symbolp var)
- (unless (and (setq x (get var 'cmp-type)) (equal x type))
- (return nil))
- (warn "The variable name ~s is not a symbol." var)))))
- (ftype
- (if (or (endp (cdr decl))
- (not (consp (cadr decl)))
- (not (eq (caadr decl) 'function))
- (endp (cdadr decl)))
- (warn "The function declaration ~s is illegal." decl)
- (dolist** (fname (cddr decl) t)
- (unless (and (get fname 'proclaimed-function)
- (equal (function-arg-types (cadadr decl))
- (get fname 'proclaimed-arg-types))
- (equal (function-return-type (cddadr decl))
- (get fname 'proclaimed-return-type)))
- (return nil)))))
- (function
- (if (or (endp (cdr decl)) (endp (cddr decl)))
- (warn "The function declaration ~s is illegal." decl)
- (and (get (cadr decl) 'proclaimed-function)
- (equal (function-arg-types (caddr decl))
- (get (cadr decl) 'proclaimed-arg-types))
- (equal (function-return-type (cdddr decl))
- (get (cadr decl) 'proclaimed-return-type)))))
- (inline (dolist** (fun (cdr decl) t)
- (if (symbolp fun)
- (when (get fun 'cmp-notinline) (return nil))
- (warn "The function name ~s is not a symbol." fun))))
- (notinline (dolist** (fun (cdr decl) t)
- (if (symbolp fun)
- (unless (get fun 'cmp-notinline) (return nil))
- (warn "The function name ~s is not a symbol." fun))))
- ((object ignore)
- (dolist** (var (cdr decl) t)
- (unless (symbolp var)
- (warn "The variable name ~s is not a symbol." var))))
- (declaration (dolist** (x (cdr decl) t)
- (if (symbolp x)
- (unless (member x *alien-declarations*) (return nil))
- (warn "The declaration specifier ~s is not a symbol."
- x))))
- ((array atom bignum bit bit-vector character common compiled-function
- complex cons double-float fixnum float hash-table integer keyword list
- long-float nil null number package pathname random-state ratio rational
- readtable sequence short-float simple-array simple-bit-vector
- simple-string simple-vector single-float standard-char stream string
- string-char symbol t vector signed-byte unsigned-byte)
- (let ((type (type-filter (car decl))))
- (dolist** (var (cdr decl) t)
- (if (symbolp var)
- (unless (equal (get var 'cmp-type) type) (return nil))
- (warn "The variable name ~s is not a symbol." var)))))
- (otherwise
- (unless (member (car decl) *alien-declarations*)
- (warn "The declaration specifier ~s is unknown." (car decl))))
- )
- )
-
-